home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / xlisp2.1 / xldist02.zoo / sources / xlcont.c < prev    next >
Encoding:
C/C++ Source or Header  |  1990-11-09  |  29.1 KB  |  1,555 lines
  1. /* xlcont - xlisp special forms */
  2. /*        Copyright (c) 1985, by David Michael Betz
  3.         All Rights Reserved
  4.         Permission is granted for unrestricted non-commercial use        */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* external variables */
  9. extern LVAL xlenv,xlfenv,xldenv,xlvalue;
  10. extern LVAL s_setf,s_car,s_cdr,s_nth,s_aref,s_get;
  11. extern LVAL s_svalue,s_sfunction,s_splist;
  12. extern LVAL s_lambda,s_macro;
  13. extern LVAL s_comma,s_comat;
  14. extern LVAL s_unbound;
  15. extern LVAL true;
  16. #ifdef COMMONLISP
  17. extern LVAL s_elt;
  18. #endif
  19.  
  20.  
  21. /* forward declarations */
  22. #ifdef ANSI
  23. LVAL bquote1(LVAL expr);
  24. LVAL let(int pflag);
  25. LVAL flet(LVAL type, int letflag);
  26. LVAL prog(int pflag);
  27. LVAL progx(int n);
  28. LVAL doloop(int pflag);
  29. LVAL evarg(LVAL *pargs);
  30. LVAL match(int type, LVAL *pargs);
  31. LVAL evmatch(int type, LVAL *pargs);
  32. VOID placeform(LVAL place, LVAL value);
  33. VOID setffunction(LVAL fun, LVAL place, LVAL value);
  34. VOID dobindings(LVAL list, LVAL env);
  35. VOID doupdates(LVAL list, int pflags);
  36. VOID tagbody(void);
  37. VOID toofew(LVAL args);
  38. VOID toomany(LVAL args);
  39. int  keypresent(LVAL key, LVAL list);
  40. #else
  41. FORWARD LVAL bquote1();
  42. FORWARD LVAL let();
  43. FORWARD LVAL flet();
  44. FORWARD LVAL prog();
  45. FORWARD LVAL progx();
  46. FORWARD LVAL doloop();
  47. FORWARD LVAL evarg();
  48. FORWARD LVAL match();
  49. FORWARD LVAL evmatch();
  50. FORWARD VOID placeform();
  51. FORWARD VOID setffunction();
  52. FORWARD VOID dobindings();
  53. FORWARD VOID doupdates();
  54. FORWARD VOID tagbody();
  55. FORWARD VOID toofew();
  56. FORWARD VOID toomany();
  57. #endif
  58.  
  59. /* dummy node type for a list */
  60. #define LIST    -1
  61.  
  62. /* xquote - special form 'quote' */
  63. LVAL xquote()
  64. {
  65.     LVAL val;
  66.     val = xlgetarg();
  67.     xllastarg();
  68.     return (val);
  69. }
  70.  
  71. /* xfunction - special form 'function' */
  72. LVAL xfunction()
  73. {
  74.     LVAL val;
  75.  
  76.     /* get the argument */
  77.     val = xlgetarg();
  78.     xllastarg();
  79.  
  80.     /* create a closure for lambda expressions */
  81.     if (consp(val) && car(val) == s_lambda && consp(cdr(val)))
  82.         val = xlclose(NIL,s_lambda,car(cdr(val)),cdr(cdr(val)),xlenv,xlfenv);
  83.  
  84.     /* otherwise, get the value of a symbol */
  85.     else if (symbolp(val))
  86.         val = xlgetfunction(val);
  87.  
  88.     /* otherwise, its an error */
  89.     else
  90.         xlerror("not a function",val);
  91.  
  92.     /* return the function */
  93.     return (val);
  94. }
  95.  
  96. /* xbquote - back quote special form */
  97. LVAL xbquote()
  98. {
  99.     LVAL expr;
  100.  
  101.     /* get the expression */
  102.     expr = xlgetarg();
  103.     xllastarg();
  104.  
  105.     /* fill in the template */
  106.     return (bquote1(expr));
  107. }
  108.  
  109. /* bquote1 - back quote helper function */
  110. LOCAL LVAL bquote1(expr)
  111.   LVAL expr;
  112. {
  113.     LVAL val,list,last,new;
  114.  
  115.     /* handle atoms */
  116.     if (atom(expr))
  117.         val = expr;
  118.  
  119.     /* handle (comma <expr>) */
  120.     else if (car(expr) == s_comma) {
  121.         if (atom(cdr(expr)))
  122.             xlfail("bad comma expression");
  123.         val = xleval(car(cdr(expr)));
  124.     }
  125.  
  126.     /* handle ((comma-at <expr>) ... ) */
  127.     else if (consp(car(expr)) && car(car(expr)) == s_comat) {
  128.         xlstkcheck(2);
  129.         xlsave(list);
  130.         xlsave(val);
  131.         if (atom(cdr(car(expr))))
  132.             xlfail("bad comma-at expression");
  133.         list = xleval(car(cdr(car(expr))));
  134.         for (last = NIL; consp(list); list = cdr(list)) {
  135.             new = consa(car(list));
  136.             if (last)
  137.                 rplacd(last,new);
  138.             else
  139.                 val = new;
  140.             last = new;
  141.         }
  142.         if (last)
  143.             rplacd(last,bquote1(cdr(expr)));
  144.         else
  145.             val = bquote1(cdr(expr));
  146.         xlpopn(2);
  147.     }
  148.  
  149.     /* handle any other list */
  150.     else {
  151.         xlsave1(val);
  152.         val = consa(NIL);
  153.         rplaca(val,bquote1(car(expr)));
  154.         rplacd(val,bquote1(cdr(expr)));
  155.         xlpop();
  156.     }
  157.  
  158.     /* return the result */
  159.     return (val);
  160. }
  161.  
  162. /* xlambda - special form 'lambda' */
  163. LVAL xlambda()
  164. {
  165.     LVAL fargs,arglist,val;
  166.  
  167.     /* get the formal argument list and function body */
  168.     xlsave1(arglist);
  169.     fargs = xlgalist();
  170.     arglist = makearglist(xlargc,xlargv);
  171.  
  172.     /* create a new function definition */
  173.     val = xlclose(NIL,s_lambda,fargs,arglist,xlenv,xlfenv);
  174.  
  175.     /* restore the stack and return the closure */
  176.     xlpop();
  177.     return (val);
  178. }
  179.  
  180. /* xgetlambda - get the lambda expression associated with a closure */
  181. LVAL xgetlambda()
  182. {
  183.     LVAL closure;
  184.     closure = xlgaclosure();
  185.     return (cons(gettype(closure),
  186.                  cons(getlambda(closure),getbody(closure))));
  187. }
  188.  
  189. /* xsetq - special form 'setq' */
  190. LVAL xsetq()
  191. {
  192.     LVAL sym,val;
  193.  
  194.     /* handle each pair of arguments */
  195.     for (val = NIL; moreargs(); ) {
  196.         sym = xlgasymbol();
  197.         val = xleval(nextarg());
  198.         xlsetvalue(sym,val);
  199.     }
  200.  
  201.     /* return the result value */
  202.     return (val);
  203. }
  204.  
  205. /* xpsetq - special form 'psetq' */
  206. LVAL xpsetq()
  207. {
  208.     LVAL plist,sym,val;
  209.  
  210.     /* protect some pointers */
  211.     xlsave1(plist);
  212.  
  213.     /* handle each pair of arguments */
  214.     for (val = NIL; moreargs(); ) {
  215.         sym = xlgasymbol();
  216.         val = xleval(nextarg());
  217.         plist = cons(cons(sym,val),plist);
  218.     }
  219.  
  220.     /* do parallel sets */
  221.     for (; plist; plist = cdr(plist))
  222.         xlsetvalue(car(car(plist)),cdr(car(plist)));
  223.  
  224.     /* restore the stack */
  225.     xlpop();
  226.  
  227.     /* return the result value */
  228.     return (val);
  229. }
  230.  
  231. /* xsetf - special form 'setf' */
  232. LVAL xsetf()
  233. {
  234.     LVAL place,value;
  235.  
  236.     /* protect some pointers */
  237.     xlsave1(value);
  238.  
  239.     /* handle each pair of arguments */
  240.     while (moreargs()) {
  241.  
  242.         /* get place and value */
  243.         place = xlgetarg();
  244.         value = xleval(nextarg());
  245.  
  246.         /* expand macros in the place form */
  247.         if (consp(place))
  248.             place = xlexpandmacros(place);
  249.  
  250.         /* check the place form */
  251.         if (symbolp(place))
  252.             xlsetvalue(place,value);
  253.         else if (consp(place))
  254.             placeform(place,value);
  255.         else
  256.             xlfail("bad place form");
  257.     }
  258.  
  259.     /* restore the stack */
  260.     xlpop();
  261.  
  262.     /* return the value */
  263.     return (value);
  264. }
  265.  
  266. /* placeform - handle a place form other than a symbol */
  267. LOCAL VOID placeform(place,value)
  268.   LVAL place,value;
  269. {
  270.     LVAL fun,arg1,arg2;
  271.     FIXTYPE i;    /* TAA fix */
  272.  
  273.     /* check the function name */
  274.     if ((fun = match(SYMBOL,&place)) == s_get) {
  275.         xlstkcheck(2);
  276.         xlsave(arg1);
  277.         xlsave(arg2);
  278.         arg1 = evmatch(SYMBOL,&place);
  279.         arg2 = evmatch(SYMBOL,&place);
  280.         if (place) toomany(place);
  281.         xlputprop(arg1,value,arg2);
  282.         xlpopn(2);
  283.     }
  284.     else if (fun == s_svalue) {
  285.         arg1 = evmatch(SYMBOL,&place);
  286.         if (place) toomany(place);
  287.         if ( arg1 == true || 
  288.             arg1 == s_unbound ||
  289.             (getstring(getpname(arg1)))[0] == ':' )
  290.                 xlerror( "constant value", arg1 ); /* Bug FIX TAA */
  291.         setvalue(arg1,value);
  292.     }
  293.     else if (fun == s_sfunction) {
  294.         arg1 = evmatch(SYMBOL,&place);
  295.         if (place) toomany(place);
  296.         setfunction(arg1,value);
  297.     }
  298.     else if (fun == s_splist) {
  299.         arg1 = evmatch(SYMBOL,&place);
  300.         if (place) toomany(place);
  301.         setplist(arg1,value);
  302.     }
  303.     else if (fun == s_car) {
  304.         arg1 = evmatch(CONS,&place);
  305.         if (place) toomany(place);
  306.         rplaca(arg1,value);
  307.     }
  308.     else if (fun == s_cdr) {
  309.         arg1 = evmatch(CONS,&place);
  310.         if (place) toomany(place);
  311.         rplacd(arg1,value);
  312.     }
  313.     else if (fun == s_nth) {
  314.         xlsave1(arg1);
  315.         arg1 = evmatch(FIXNUM,&place);
  316.         arg2 = evmatch(LIST,&place);
  317.         if (place) toomany(place);
  318.         for (i = /*(int) */getfixnum(arg1); i > 0 && consp(arg2); --i)
  319.             arg2 = cdr(arg2);
  320.         if (consp(arg2))
  321.             rplaca(arg2,value);
  322.         xlpop();
  323.     }
  324.     else if (fun == s_aref) {
  325.         xlsave1(arg1);
  326. #ifdef COMMONLISP        /* allows (setf (aref...)..) to work on strings */
  327.         arg1 = evarg(&place);
  328. #else
  329.         arg1 = evmatch(VECTOR,&place);
  330. #endif
  331.         arg2 = evmatch(FIXNUM,&place); i = getfixnum(arg2);
  332.         if (place) toomany(place);
  333. #ifdef COMMONLISP
  334.         if (stringp(arg1)) {    /* extension for strings */
  335.             if (i < 0 || i >= getslength(arg1)-1)
  336.                 xlerror("index out of range",arg2);
  337.             if (!charp(value)) 
  338.                 xlerror("strings only contain characters",value);
  339.             setstringch(arg1,(int)i,getchcode(value));
  340.         }
  341.         else if(vectorp(arg1)) {
  342. #endif
  343.         if (i < 0 || i >= getsize(arg1))
  344.             xlerror("index out of range",arg2);
  345.         setelement(arg1,(int)i,value);    /*taa fix -- added cast */
  346. #ifdef COMMONLISP
  347.         }
  348.         else xlbadtype(arg1);
  349. #endif
  350.         xlpop();
  351.     }
  352. #ifdef COMMONLISP    /* Defines (setf (elt...)...) */
  353.     else if (fun == s_elt) {
  354.         xlsave1(arg1);
  355.         arg1 = evarg(&place);
  356.         arg2 = evmatch(FIXNUM,&place); i = getfixnum(arg2);
  357.         if (place) toomany(place);
  358.         if (listp(arg1)) {
  359.             for (; i > 0 && consp(arg1); --i)
  360.                 arg1 = cdr(arg1);
  361.             if((!consp(arg1)) || i < 0)
  362.                 xlerror("index out of range",arg2);
  363.             rplaca(arg1,value);
  364.         }
  365.         else if (ntype(arg1) == STRING) {
  366.             if (i < 0 || i >= getslength(arg1)-1)
  367.                 xlerror("index out of range",arg2);
  368.             if (!charp(value)) 
  369.                 xlerror("strings only contain characters",value);
  370.             setstringch(arg1,i,getchcode(value));
  371.         }
  372.         else if (ntype(arg1) == VECTOR) {
  373.             if (i < 0 || i >= getsize(arg1))
  374.                 xlerror("index out of range",arg2);
  375.             setelement(arg1,(int)i,value);
  376.         }
  377.         else xlbadtype(arg1);
  378.         xlpop();
  379.     }
  380. #endif
  381.     else if ((fun = xlgetprop(fun,s_setf)) != 0)
  382.         setffunction(fun,place,value);
  383.     else
  384.         xlfail("bad place form");
  385. }
  386.  
  387. /* setffunction - call a user defined setf function */
  388. LOCAL VOID setffunction(fun,place,value)
  389.   LVAL fun,place,value;
  390. {
  391.     LVAL *newfp;
  392.     int argc;
  393.  
  394.     /* create the new call frame */
  395.     newfp = xlsp;
  396.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  397.     pusharg(fun);
  398.     pusharg(NIL);
  399.  
  400.     /* push the values of all of the place expressions and the new value */
  401.     for (argc = 1; consp(place); place = cdr(place), ++argc)
  402.         pusharg(xleval(car(place)));
  403.     pusharg(value);
  404.  
  405.     /* insert the argument count and establish the call frame */
  406.     newfp[2] = cvfixnum((FIXTYPE)argc);
  407.     xlfp = newfp;
  408.  
  409.     /* apply the function */
  410.     xlapply(argc);
  411. }
  412.                        
  413. /* xdefun - special form 'defun' */
  414. LVAL xdefun()
  415. {
  416.     LVAL sym,fargs,arglist;
  417.  
  418.     /* get the function symbol and formal argument list */
  419.     xlsave1(arglist);
  420.     sym = xlgasymbol();
  421.     fargs = xlgalist();
  422.     arglist = makearglist(xlargc,xlargv);
  423.  
  424.     /* make the symbol point to a new function definition */
  425.     xlsetfunction(sym,xlclose(sym,s_lambda,fargs,arglist,xlenv,xlfenv));
  426.  
  427.     /* restore the stack and return the function symbol */
  428.     xlpop();
  429.     return (sym);
  430. }
  431.  
  432. /* xdefmacro - special form 'defmacro' */
  433. LVAL xdefmacro()
  434. {
  435.     LVAL sym,fargs,arglist;
  436.  
  437.     /* get the function symbol and formal argument list */
  438.     xlsave1(arglist);
  439.     sym = xlgasymbol();
  440.     fargs = xlgalist();
  441.     arglist = makearglist(xlargc,xlargv);
  442.  
  443.     /* make the symbol point to a new function definition */
  444.     xlsetfunction(sym,xlclose(sym,s_macro,fargs,arglist,NIL,NIL));
  445.  
  446.     /* restore the stack and return the function symbol */
  447.     xlpop();
  448.     return (sym);
  449. }
  450.  
  451. /* xcond - special form 'cond' */
  452. LVAL xcond()
  453. {
  454.     LVAL list,val;
  455.  
  456.     /* find a predicate that is true */
  457.     for (val = NIL; moreargs(); ) {
  458.  
  459.         /* get the next conditional */
  460.         list = nextarg();
  461.  
  462.         /* evaluate the predicate part */
  463.         if (consp(list) && ((val = xleval(car(list))) != 0)) {
  464.  
  465.             /* evaluate each expression */
  466.             for (list = cdr(list); consp(list); list = cdr(list))
  467.                 val = xleval(car(list));
  468.  
  469.             /* exit the loop */
  470.             break;
  471.         }
  472.     }
  473.  
  474.     /* return the value */
  475.     return (val);
  476. }
  477.  
  478. /* xwhen - special form 'when' */
  479. LVAL xwhen()
  480. {
  481.     LVAL val;
  482.  
  483.     /* check the test expression */
  484.     if ((val = xleval(xlgetarg())) != 0)
  485.         while (moreargs())
  486.             val = xleval(nextarg());
  487.  
  488.     /* return the value */
  489.     return (val);
  490. }
  491.  
  492. /* xunless - special form 'unless' */
  493. LVAL xunless()
  494. {
  495.     LVAL val=NIL;
  496.  
  497.     /* check the test expression */
  498.     if (xleval(xlgetarg()) == NIL)
  499.         while (moreargs())
  500.             val = xleval(nextarg());
  501.  
  502.     /* return the value */
  503.     return (val);
  504. }
  505.  
  506. /* xcase - special form 'case' */
  507. LVAL xcase()
  508. {
  509.     LVAL key,list,cases,val;
  510.  
  511.     /* protect some pointers */
  512.     xlsave1(key);
  513.  
  514.     /* get the key expression */
  515.     key = xleval(nextarg());
  516.  
  517.     /* find a case that matches */
  518.     for (val = NIL; moreargs(); ) {
  519.  
  520.         /* get the next case clause */
  521.         list = nextarg();
  522.  
  523.         /* make sure this is a valid clause */
  524.         if (consp(list)) {
  525.  
  526.             /* compare the key list against the key */
  527.             if (((cases = car(list)) == true && ! moreargs())||
  528.                 (listp(cases) && keypresent(key,cases)) ||
  529.                 eql(key,cases)) {
  530.  
  531.                 /* evaluate each expression */
  532.                 for (list = cdr(list); consp(list); list = cdr(list))
  533.                     val = xleval(car(list));
  534.  
  535.                 /* exit the loop */
  536.                 break;
  537.             }
  538.         }
  539.         else
  540.             xlerror("bad case clause",list);
  541.     }
  542.  
  543.     /* restore the stack */
  544.     xlpop();
  545.  
  546.     /* return the value */
  547.     return (val);
  548. }
  549.  
  550. /* keypresent - check for the presence of a key in a list */
  551. LOCAL int keypresent(key,list)
  552.   LVAL key,list;
  553. {
  554.     for (; consp(list); list = cdr(list))
  555.         if (eql(car(list),key))
  556.             return (TRUE);
  557.     return (FALSE);
  558. }
  559.  
  560. /* xand - special form 'and' */
  561. LVAL xand()
  562. {
  563.     LVAL val;
  564.  
  565.     /* evaluate each argument */
  566.     for (val = true; moreargs(); )
  567.         if ((val = xleval(nextarg())) == NIL)
  568.             break;
  569.  
  570.     /* return the result value */
  571.     return (val);
  572. }
  573.  
  574. /* xor - special form 'or' */
  575. LVAL xor()
  576. {
  577.     LVAL val;
  578.  
  579.     /* evaluate each argument */
  580.     for (val = NIL; moreargs(); )
  581.         if ( (val = xleval(nextarg())) != 0)
  582.             break;
  583.  
  584.     /* return the result value */
  585.     return (val);
  586. }
  587.  
  588. /* xif - special form 'if' */
  589. LVAL xif()
  590. {
  591.     LVAL testexpr,thenexpr,elseexpr;
  592.  
  593.     /* get the test expression, then clause and else clause */
  594.     testexpr = xlgetarg();
  595.     thenexpr = xlgetarg();
  596.     elseexpr = (moreargs() ? xlgetarg() : NIL);
  597.     xllastarg();
  598.  
  599.     /* evaluate the appropriate clause */
  600.     return (xleval(xleval(testexpr) ? thenexpr : elseexpr));
  601. }
  602.  
  603. /* xlet - special form 'let' */
  604. LVAL xlet()
  605. {
  606.     return (let(TRUE));
  607. }
  608.  
  609. /* xletstar - special form 'let*' */
  610. LVAL xletstar()
  611. {
  612.     return (let(FALSE));
  613. }
  614.  
  615. /* let - common let routine */
  616. LOCAL LVAL let(pflag)
  617.   int pflag;
  618. {
  619.     LVAL newenv,val;
  620.  
  621.     /* protect some pointers */
  622.     xlsave1(newenv);
  623.  
  624.     /* create a new environment frame */
  625.     newenv = xlframe(xlenv);
  626.  
  627.     /* get the list of bindings and bind the symbols */
  628.     if (!pflag) xlenv = newenv;
  629.     dobindings(xlgalist(),newenv);
  630.     if (pflag) xlenv = newenv;
  631.  
  632.     /* execute the code */
  633.     for (val = NIL; moreargs(); )
  634.         val = xleval(nextarg());
  635.  
  636.     /* unbind the arguments */
  637.     xlenv = cdr(xlenv);
  638.  
  639.     /* restore the stack */
  640.     xlpop();
  641.  
  642.     /* return the result */
  643.     return (val);
  644. }
  645.  
  646. /* xflet - built-in function 'flet' */
  647. LVAL xflet()
  648. {
  649.     return (flet(s_lambda,TRUE));
  650. }
  651.  
  652. /* xlabels - built-in function 'labels' */
  653. LVAL xlabels()
  654. {
  655.     return (flet(s_lambda,FALSE));
  656. }
  657.  
  658. /* xmacrolet - built-in function 'macrolet' */
  659. LVAL xmacrolet()
  660. {
  661.     return (flet(s_macro,TRUE));
  662. }
  663.  
  664. /* flet - common flet/labels/macrolet routine */
  665. LOCAL LVAL flet(type,letflag)
  666.   LVAL type; int letflag;
  667. {
  668.     LVAL list,bnd,sym,fargs,val;
  669.  
  670.     /* create a new environment frame */
  671.     xlfenv = xlframe(xlfenv);
  672.  
  673.     /* bind each symbol in the list of bindings */
  674.     for (list = xlgalist(); consp(list); list = cdr(list)) {
  675.  
  676.         /* get the next binding */
  677.         bnd = car(list);
  678.  
  679.         /* get the symbol and the function definition */
  680.         sym = match(SYMBOL,&bnd);
  681.         fargs = match(LIST,&bnd);
  682.         val = xlclose(sym,type,fargs,bnd,xlenv,(letflag?cdr(xlfenv):xlfenv));
  683.  
  684.         /* bind the value to the symbol */
  685.         xlfbind(sym,val);
  686.     }
  687.  
  688.     /* execute the code */
  689.     for (val = NIL; moreargs(); )
  690.         val = xleval(nextarg());
  691.  
  692.     /* unbind the arguments */
  693.     xlfenv = cdr(xlfenv);
  694.  
  695.     /* return the result */
  696.     return (val);
  697. }
  698.  
  699. /* xprog - special form 'prog' */
  700. LVAL xprog()
  701. {
  702.     return (prog(TRUE));
  703. }
  704.  
  705. /* xprogstar - special form 'prog*' */
  706. LVAL xprogstar()
  707. {
  708.     return (prog(FALSE));
  709. }
  710.  
  711. #ifdef MSC6
  712. /* no optimization which interferes with setjmp */
  713. #pragma optimize("elg",off)
  714. #endif
  715.  
  716. /* prog - common prog routine */
  717. LOCAL LVAL prog(pflag)
  718.   int pflag;
  719. {
  720.     LVAL newenv,val;
  721.     CONTEXT cntxt;
  722.  
  723.     /* protect some pointers */
  724.     xlsave1(newenv);
  725.  
  726.     /* create a new environment frame */
  727.     newenv = xlframe(xlenv);
  728.  
  729.     /* establish a new execution context */
  730.     xlbegin(&cntxt,CF_RETURN,NIL);
  731.     if (setjmp(cntxt.c_jmpbuf))
  732.         val = xlvalue;
  733.     else {
  734.  
  735.         /* get the list of bindings and bind the symbols */
  736.         if (!pflag) xlenv = newenv;
  737.         dobindings(xlgalist(),newenv);
  738.         if (pflag) xlenv = newenv;
  739.  
  740.         /* execute the code */
  741.         tagbody();
  742.         val = NIL;
  743.  
  744.         /* unbind the arguments */
  745.         xlenv = cdr(xlenv);
  746.     }
  747.     xlend(&cntxt);
  748.  
  749.     /* restore the stack */
  750.     xlpop();
  751.  
  752.     /* return the result */
  753.     return (val);
  754. }
  755.  
  756. #ifdef MSC6
  757. #pragma optimize("",on)
  758. #endif
  759.  
  760. /* xgo - special form 'go' */
  761. LVAL xgo()
  762. {
  763.     LVAL label;
  764.  
  765.     /* get the target label */
  766.     label = xlgetarg();
  767.     xllastarg();
  768.  
  769.     /* transfer to the label */
  770.     xlgo(label);
  771.     return (NIL);
  772. }
  773.  
  774. /* xreturn - special form 'return' */
  775. LVAL xreturn()
  776. {
  777.     LVAL val;
  778.  
  779.     /* get the return value */
  780.     val = (moreargs() ? xleval(nextarg()) : NIL);
  781.     xllastarg();
  782.  
  783.     /* return from the inner most block */
  784.     xlreturn(NIL,val);
  785.     return (NIL);
  786. }
  787.  
  788. /* xrtnfrom - special form 'return-from' */
  789. LVAL xrtnfrom()
  790. {
  791.     LVAL name,val;
  792.  
  793.     /* get the return value */
  794.     name = xlgasymbol();
  795.     val = (moreargs() ? xleval(nextarg()) : NIL);
  796.     xllastarg();
  797.  
  798.     /* return from the inner most block */
  799.     xlreturn(name,val);
  800.     return (NIL);
  801. }
  802.  
  803. /* xprog1 - special form 'prog1' */
  804. LVAL xprog1()
  805. {
  806.     return (progx(1));
  807. }
  808.  
  809. /* xprog2 - special form 'prog2' */
  810. LVAL xprog2()
  811. {
  812.     return (progx(2));
  813. }
  814.  
  815. /* progx - common progx code */
  816. LOCAL LVAL progx(n)
  817.   int n;
  818. {
  819.     LVAL val;
  820.  
  821.     /* protect some pointers */
  822.     xlsave1(val);
  823.  
  824.     /* evaluate the first n expressions */
  825.     while (moreargs() && --n >= 0)
  826.         val = xleval(nextarg());
  827.  
  828.     /* evaluate each remaining argument */
  829.     while (moreargs())
  830.         xleval(nextarg());
  831.  
  832.     /* restore the stack */
  833.     xlpop();
  834.  
  835.     /* return the last test expression value */
  836.     return (val);
  837. }
  838.  
  839. /* xprogn - special form 'progn' */
  840. LVAL xprogn()
  841. {
  842.     LVAL val;
  843.  
  844.     /* evaluate each expression */
  845.     for (val = NIL; moreargs(); )
  846.         val = xleval(nextarg());
  847.  
  848.     /* return the last test expression value */
  849.     return (val);
  850. }
  851.  
  852. /* xprogv - special form 'progv' */
  853. LVAL xprogv()
  854. {
  855.     LVAL olddenv,vars,vals,val;
  856.  
  857.     /* protect some pointers */
  858.     xlstkcheck(2);
  859.     xlsave(vars);
  860.     xlsave(vals);
  861.  
  862.     /* get the list of variables and the list of values */
  863.     vars = xlgalist(); vars = xleval(vars);
  864.     vals = xlgalist(); vals = xleval(vals);
  865.  
  866.     /* bind the values to the variables */
  867.     for (olddenv = xldenv; consp(vars); vars = cdr(vars)) {
  868.         if (!symbolp(car(vars)))
  869.             xlerror("expecting a symbol",car(vars));
  870.         if (consp(vals)) {
  871.             xldbind(car(vars),car(vals));
  872.             vals = cdr(vals);
  873.         }
  874.         else
  875.             xldbind(car(vars),s_unbound);
  876.     }
  877.  
  878.     /* evaluate each expression */
  879.     for (val = NIL; moreargs(); )
  880.         val = xleval(nextarg());
  881.  
  882.     /* restore the previous environment and the stack */
  883.     xlunbind(olddenv);
  884.     xlpopn(2);
  885.  
  886.     /* return the last test expression value */
  887.     return (val);
  888. }
  889.  
  890. #ifdef MSC6
  891. /* no optimization which interferes with setjmp */
  892. #pragma optimize("elg",off)
  893. #endif
  894.  
  895. /* xloop - special form 'loop' */
  896. LVAL xloop()
  897. {
  898.     LVAL *argv,arg,val;
  899.     CONTEXT cntxt;
  900.     int argc;
  901.  
  902.     /* protect some pointers */
  903.     xlsave1(arg);
  904.  
  905.     /* establish a new execution context */
  906.     xlbegin(&cntxt,CF_RETURN,NIL);
  907.     if (setjmp(cntxt.c_jmpbuf))
  908.         val = xlvalue;
  909.     else
  910.         for (argv = xlargv, argc = xlargc; ; xlargv = argv, xlargc = argc)
  911.             while (moreargs()) {
  912.                 arg = nextarg();
  913.                 if (consp(arg))
  914.                     xleval(arg);
  915.             }
  916.     xlend(&cntxt);
  917.  
  918.     /* restore the stack */
  919.     xlpop();
  920.  
  921.     /* return the result */
  922.     return (val);
  923. }
  924.  
  925. #ifdef MSC6
  926. #pragma optimize("",on)
  927. #endif
  928.  
  929. /* xdo - special form 'do' */
  930. LVAL xdo()
  931. {
  932.     return (doloop(TRUE));
  933. }
  934.  
  935. /* xdostar - special form 'do*' */
  936. LVAL xdostar()
  937. {
  938.     return (doloop(FALSE));
  939. }
  940.  
  941. #ifdef MSC6
  942. /* no optimization which interferes with setjmp */
  943. #pragma optimize("elg",off)
  944. #endif
  945.  
  946. /* doloop - common do routine */
  947. LOCAL LVAL doloop(pflag)
  948.   int pflag;
  949. {
  950.     LVAL newenv,*argv,blist,clist,test,val;
  951.     CONTEXT cntxt;
  952.     int argc;
  953.  
  954.     /* protect some pointers */
  955.     xlsave1(newenv);
  956.  
  957.     /* get the list of bindings, the exit test and the result forms */
  958.     blist = xlgalist();
  959.     clist = xlgalist();
  960.     test = (consp(clist) ? car(clist) : NIL);
  961.     argv = xlargv;
  962.     argc = xlargc;
  963.  
  964.     /* create a new environment frame */
  965.     newenv = xlframe(xlenv);
  966.  
  967.     /* establish a new execution context */
  968.     xlbegin(&cntxt,CF_RETURN,NIL);
  969.     if (setjmp(cntxt.c_jmpbuf))
  970.         val = xlvalue;
  971.     else {
  972.  
  973.         /* bind the symbols */
  974.         if (!pflag) xlenv = newenv;
  975.         dobindings(blist,newenv);
  976.         if (pflag) xlenv = newenv;
  977.  
  978.         /* execute the loop as long as the test is false */
  979.         for (val = NIL; xleval(test) == NIL; doupdates(blist,pflag)) {
  980.             xlargv = argv;
  981.             xlargc = argc;
  982.             tagbody();
  983.         }
  984.  
  985.         /* evaluate the result expression */
  986.         if (consp(clist))
  987.             for (clist = cdr(clist); consp(clist); clist = cdr(clist))
  988.                 val = xleval(car(clist));
  989.  
  990.         /* unbind the arguments */
  991.         xlenv = cdr(xlenv);
  992.     }
  993.     xlend(&cntxt);
  994.  
  995.     /* restore the stack */
  996.     xlpop();
  997.  
  998.     /* return the result */
  999.     return (val);
  1000. }
  1001.  
  1002. /* xdolist - special form 'dolist' */
  1003. LVAL xdolist()
  1004. {
  1005.     LVAL list,*argv,clist,sym,val;
  1006.     CONTEXT cntxt;
  1007.     int argc;
  1008.  
  1009.     /* protect some pointers */
  1010.     xlsave1(list);
  1011.  
  1012.     /* get the control list (sym list result-expr) */
  1013.     clist = xlgalist();
  1014.     sym = match(SYMBOL,&clist);
  1015.     list = evmatch(LIST,&clist);
  1016.     argv = xlargv;
  1017.     argc = xlargc;
  1018.  
  1019.     /* initialize the local environment */
  1020.     xlenv = xlframe(xlenv);
  1021.     xlbind(sym,NIL);
  1022.  
  1023.     /* establish a new execution context */
  1024.     xlbegin(&cntxt,CF_RETURN,NIL);
  1025.     if (setjmp(cntxt.c_jmpbuf))
  1026.         val = xlvalue;
  1027.     else {
  1028.  
  1029.         /* loop through the list */
  1030.         for (val = NIL; consp(list); list = cdr(list)) {
  1031.  
  1032.             /* bind the symbol to the next list element */
  1033.             xlsetvalue(sym,car(list));
  1034.  
  1035.             /* execute the loop body */
  1036.             xlargv = argv;
  1037.             xlargc = argc;
  1038.             tagbody();
  1039.         }
  1040.  
  1041.         /* evaluate the result expression */
  1042.         xlsetvalue(sym,NIL);
  1043.         val = (consp(clist) ? xleval(car(clist)) : NIL);
  1044.  
  1045.         /* unbind the arguments */
  1046.         xlenv = cdr(xlenv);
  1047.     }
  1048.     xlend(&cntxt);
  1049.  
  1050.     /* restore the stack */
  1051.     xlpop();
  1052.  
  1053.     /* return the result */
  1054.     return (val);
  1055. }
  1056.  
  1057. /* xdotimes - special form 'dotimes' */
  1058. LVAL xdotimes()
  1059. {
  1060.     LVAL *argv,clist,sym,cnt,val;
  1061.     CONTEXT cntxt;
  1062.     int argc;
  1063.     FIXTYPE n,i; /* TAA MOD (fix) */
  1064.  
  1065.     /* get the control list (sym list result-expr) */
  1066.     clist = xlgalist();
  1067.     sym = match(SYMBOL,&clist);
  1068.     cnt = evmatch(FIXNUM,&clist); n = getfixnum(cnt);
  1069.     argv = xlargv;
  1070.     argc = xlargc;
  1071.  
  1072.     /* initialize the local environment */
  1073.     xlenv = xlframe(xlenv);
  1074.     xlbind(sym,NIL);
  1075.  
  1076.     /* establish a new execution context */
  1077.     xlbegin(&cntxt,CF_RETURN,NIL);
  1078.     if (setjmp(cntxt.c_jmpbuf))
  1079.         val = xlvalue;
  1080.     else {
  1081.  
  1082.         /* loop through for each value from zero to n-1 */
  1083.         for (val = NIL, i = 0; i < n; ++i) {
  1084.  
  1085.             /* bind the symbol to the next list element */
  1086.             xlsetvalue(sym,cvfixnum((FIXTYPE)i));
  1087.  
  1088.             /* execute the loop body */
  1089.             xlargv = argv;
  1090.             xlargc = argc;
  1091.             tagbody();
  1092.         }
  1093.  
  1094.         /* evaluate the result expression */
  1095.         xlsetvalue(sym,cnt);
  1096.         val = (consp(clist) ? xleval(car(clist)) : NIL);
  1097.  
  1098.         /* unbind the arguments */
  1099.         xlenv = cdr(xlenv);
  1100.     }
  1101.     xlend(&cntxt);
  1102.  
  1103.     /* return the result */
  1104.     return (val);
  1105. }
  1106.  
  1107. /* xblock - special form 'block' */
  1108. LVAL xblock()
  1109. {
  1110.     LVAL name,val;
  1111.     CONTEXT cntxt;
  1112.  
  1113.     /* get the block name */
  1114.     name = xlgetarg();
  1115.     if (name && !symbolp(name))
  1116.         xlbadtype(name);
  1117.  
  1118.     /* execute the block */
  1119.     xlbegin(&cntxt,CF_RETURN,name);
  1120.     if (setjmp(cntxt.c_jmpbuf))
  1121.         val = xlvalue;
  1122.     else
  1123.         for (val = NIL; moreargs(); )
  1124.             val = xleval(nextarg());
  1125.     xlend(&cntxt);
  1126.  
  1127.     /* return the value of the last expression */
  1128.     return (val);
  1129. }
  1130.  
  1131. #ifdef MSC6
  1132. #pragma optimize("",on)
  1133. #endif
  1134.  
  1135. /* xtagbody - special form 'tagbody' */
  1136. LVAL xtagbody()
  1137. {
  1138.     tagbody();
  1139.     return (NIL);
  1140. }
  1141.  
  1142. #ifdef MSC6
  1143. /* no optimization which interferes with setjmp */
  1144. #pragma optimize("elg",off)
  1145. #endif
  1146.  
  1147. /* xcatch - special form 'catch' */
  1148. LVAL xcatch()
  1149. {
  1150.     CONTEXT cntxt;
  1151.     LVAL tag,val;
  1152.  
  1153.     /* protect some pointers */
  1154.     xlsave1(tag);
  1155.  
  1156.     /* get the tag */
  1157.     tag = xleval(nextarg());
  1158.  
  1159.     /* establish an execution context */
  1160.     xlbegin(&cntxt,CF_THROW,tag);
  1161.  
  1162.     /* check for 'throw' */
  1163.     if (setjmp(cntxt.c_jmpbuf))
  1164.         val = xlvalue;
  1165.  
  1166.     /* otherwise, evaluate the remainder of the arguments */
  1167.     else {
  1168.         for (val = NIL; moreargs(); )
  1169.             val = xleval(nextarg());
  1170.     }
  1171.     xlend(&cntxt);
  1172.  
  1173.     /* restore the stack */
  1174.     xlpop();
  1175.  
  1176.     /* return the result */
  1177.     return (val);
  1178. }
  1179.  
  1180. #ifdef MSC6
  1181. #pragma optimize("",on)
  1182. #endif
  1183.  
  1184. /* xthrow - special form 'throw' */
  1185. LVAL xthrow()
  1186. {
  1187.     LVAL tag,val;
  1188.  
  1189.     /* get the tag and value */
  1190.     tag = xleval(nextarg());
  1191.     val = (moreargs() ? xleval(nextarg()) : NIL);
  1192.     xllastarg();
  1193.  
  1194.     /* throw the tag */
  1195.     xlthrow(tag,val);
  1196.     return (NIL);
  1197. }
  1198.  
  1199. #ifdef MSC6
  1200. /* no optimization which interferes with setjmp */
  1201. #pragma optimize("elg",off)
  1202. #endif
  1203.  
  1204. /* xunwindprotect - special form 'unwind-protect' */
  1205. LVAL xunwindprotect()
  1206. {
  1207.     extern CONTEXT *xltarget;
  1208.     extern int xlmask;
  1209.     CONTEXT cntxt,*target;
  1210.     int mask,sts;
  1211.     LVAL val;
  1212.  
  1213.     /* protect some pointers */
  1214.     xlsave1(val);
  1215.  
  1216.     /* get the expression to protect */
  1217.     val = xlgetarg();
  1218.  
  1219.     /* evaluate the protected expression */
  1220.     xlbegin(&cntxt,CF_UNWIND,NIL);
  1221.     if ((sts = setjmp(cntxt.c_jmpbuf)) != 0) {
  1222.         target = xltarget;
  1223.         mask = xlmask;
  1224.         val = xlvalue;
  1225.     }
  1226.     else
  1227.         val = xleval(val);
  1228.     xlend(&cntxt);
  1229.  
  1230.     /* evaluate the cleanup expressions */
  1231.     while (moreargs())
  1232.         xleval(nextarg());
  1233.  
  1234.     /* if unwinding, continue unwinding */
  1235.     if (sts)
  1236.         xljump(target,mask,val);
  1237.  
  1238.     /* restore the stack */
  1239.     xlpop();
  1240.  
  1241.     /* return the value of the protected expression */
  1242.     return (val);
  1243. }
  1244.  
  1245. /* xerrset - special form 'errset' */
  1246. LVAL xerrset()
  1247. {
  1248.     LVAL expr,flag,val;
  1249.     CONTEXT cntxt;
  1250.  
  1251.     /* get the expression and the print flag */
  1252.     expr = xlgetarg();
  1253.     flag = (moreargs() ? xlgetarg() : true);
  1254.     xllastarg();
  1255.  
  1256.     /* establish an execution context */
  1257.     xlbegin(&cntxt,CF_ERROR,flag);
  1258.  
  1259.     /* check for error */
  1260.     if (setjmp(cntxt.c_jmpbuf))
  1261.         val = NIL;
  1262.  
  1263.     /* otherwise, evaluate the expression */
  1264.     else {
  1265.         expr = xleval(expr);
  1266.         val = consa(expr);
  1267.     }
  1268.     xlend(&cntxt);
  1269.  
  1270.     /* return the result */
  1271.     return (val);
  1272. }
  1273.  
  1274. #ifdef MSC6
  1275. #pragma optimize("",on)
  1276. #endif
  1277.  
  1278. /* xtrace - special form 'trace' */
  1279. LVAL xtrace()
  1280. {
  1281.     LVAL sym,fun,this;
  1282.  
  1283.     /* loop through all of the arguments */
  1284.     sym = xlenter("*TRACELIST*");
  1285.     while (moreargs()) {
  1286.         fun = xlgasymbol();
  1287.  
  1288.         /* check for the function name already being in the list */
  1289.         for (this = getvalue(sym); consp(this); this = cdr(this))
  1290.             if (car(this) == fun)
  1291.                 break;
  1292.  
  1293.         /* add the function name to the list */
  1294.         if (null(this))
  1295.             setvalue(sym,cons(fun,getvalue(sym)));
  1296.     }
  1297.     return (getvalue(sym));
  1298. }
  1299.  
  1300. /* xuntrace - special form 'untrace' */
  1301. LVAL xuntrace()
  1302. {
  1303.     LVAL sym,fun,this,last;
  1304.  
  1305.     /* loop through all of the arguments */
  1306.     sym = xlenter("*TRACELIST*");
  1307.     if (!moreargs()) {    /* list empty -- then untrace all functions */
  1308.         setvalue(sym,NIL);
  1309.         return (NIL);
  1310.     }
  1311.     while (moreargs()) {
  1312.         fun = xlgasymbol();
  1313.  
  1314.         /* remove the function name from the list */
  1315.         last = NIL;
  1316.         for (this = getvalue(sym); consp(this); this = cdr(this)) {
  1317.             if (car(this) == fun) {
  1318.                 if (last)
  1319.                     rplacd(last,cdr(this));
  1320.                 else
  1321.                     setvalue(sym,cdr(this));
  1322.                 break;
  1323.             }
  1324.             last = this;
  1325.         }
  1326.     }
  1327.     return (getvalue(sym));
  1328. }
  1329.  
  1330. /* dobindings - handle bindings for let/let*, prog/prog*, do/do* */
  1331. LOCAL VOID dobindings(list,env)
  1332.   LVAL list,env;
  1333. {
  1334.     LVAL bnd,sym,val;
  1335.  
  1336.     /* protect some pointers */
  1337.     xlsave1(val);
  1338.  
  1339.     /* bind each symbol in the list of bindings */
  1340.     for (; consp(list); list = cdr(list)) {
  1341.  
  1342.         /* get the next binding */
  1343.         bnd = car(list);
  1344.  
  1345.         /* handle a symbol */
  1346.         if (symbolp(bnd)) {
  1347.             sym = bnd;
  1348.             val = NIL;
  1349.         }
  1350.  
  1351.         /* handle a list of the form (symbol expr) */
  1352.         else if (consp(bnd)) {
  1353.             sym = match(SYMBOL,&bnd);
  1354.             val = evarg(&bnd);
  1355.         }
  1356.         else
  1357.             xlfail("bad binding");
  1358.  
  1359.         /* bind the value to the symbol */
  1360.         xlpbind(sym,val,env);
  1361.     }
  1362.  
  1363.     /* restore the stack */
  1364.     xlpop();
  1365. }
  1366.  
  1367. /* doupdates - handle updates for do/do* */
  1368. LOCAL VOID doupdates(list,pflag)
  1369.   LVAL list; int pflag;
  1370. {
  1371.     LVAL plist,bnd,sym,val;
  1372.  
  1373.     /* protect some pointers */
  1374.     xlstkcheck(2);
  1375.     xlsave(plist);
  1376.     xlsave(val);
  1377.  
  1378.     /* bind each symbol in the list of bindings */
  1379.     for (; consp(list); list = cdr(list)) {
  1380.  
  1381.         /* get the next binding */
  1382.         bnd = car(list);
  1383.  
  1384.         /* handle a list of the form (symbol expr) */
  1385.         if (consp(bnd)) {
  1386.             sym = match(SYMBOL,&bnd);
  1387.             bnd = cdr(bnd);
  1388.             if (bnd) {
  1389.                 val = evarg(&bnd);
  1390.                 if (pflag)
  1391.                     plist = cons(cons(sym,val),plist);
  1392.                 else
  1393.                     xlsetvalue(sym,val);
  1394.             }
  1395.         }
  1396.     }
  1397.  
  1398.     /* set the values for parallel updates */
  1399.     for (; plist; plist = cdr(plist))
  1400.         xlsetvalue(car(car(plist)),cdr(car(plist)));
  1401.  
  1402.     /* restore the stack */
  1403.     xlpopn(2);
  1404. }
  1405.  
  1406. #ifdef MSC6
  1407. /* no optimization which interferes with setjmp */
  1408. #pragma optimize("elg",off)
  1409. #endif
  1410.  
  1411. /* tagbody - execute code within a block and tagbody */
  1412. LOCAL VOID tagbody()
  1413. {
  1414.     LVAL *argv,arg;
  1415.     CONTEXT cntxt;
  1416.     int argc;
  1417.  
  1418.     /* establish an execution context */
  1419.     xlbegin(&cntxt,CF_GO,NIL);
  1420.     argc = xlargc;
  1421.     argv = xlargv;
  1422.  
  1423.     /* check for a 'go' */
  1424.     if (setjmp(cntxt.c_jmpbuf)) {
  1425.         cntxt.c_xlargc = argc;
  1426.         cntxt.c_xlargv = argv;
  1427.     }
  1428.  
  1429.     /* execute the body */
  1430.     while (moreargs()) {
  1431.         arg = nextarg();
  1432.         if (consp(arg))
  1433.             xleval(arg);
  1434.     }
  1435.     xlend(&cntxt);
  1436. }
  1437.  
  1438. #ifdef MSC6
  1439. #pragma optimize("",on)
  1440. #endif
  1441.  
  1442.  
  1443. /* match - get an argument and match its type */
  1444. LOCAL LVAL match(type,pargs)
  1445.   int type; LVAL *pargs;
  1446. {
  1447.     LVAL arg;
  1448.  
  1449.     /* make sure the argument exists */
  1450.     if (!consp(*pargs))
  1451.         toofew(*pargs);
  1452.  
  1453.     /* get the argument value */
  1454.     arg = car(*pargs);
  1455.  
  1456.     /* move the argument pointer ahead */
  1457.     *pargs = cdr(*pargs);
  1458.  
  1459.     /* check its type */
  1460.     if (type == LIST) {
  1461.         if (arg && ntype(arg) != CONS)
  1462.             xlbadtype(arg);
  1463.     }
  1464.     else {
  1465.         if (arg == NIL || ntype(arg) != type)
  1466.             xlbadtype(arg);
  1467.     }
  1468.  
  1469.     /* return the argument */
  1470.     return (arg);
  1471. }
  1472.  
  1473. /* evarg - get the next argument and evaluate it */
  1474. LOCAL LVAL evarg(pargs)
  1475.   LVAL *pargs;
  1476. {
  1477.     LVAL arg;
  1478.  
  1479.     /* protect some pointers */
  1480.     xlsave1(arg);
  1481.  
  1482.     /* make sure the argument exists */
  1483.     if (!consp(*pargs))
  1484.         toofew(*pargs);
  1485.  
  1486.     /* get the argument value */
  1487.     arg = car(*pargs);
  1488.  
  1489.     /* move the argument pointer ahead */
  1490.     *pargs = cdr(*pargs);
  1491.  
  1492.     /* evaluate the argument */
  1493.     arg = xleval(arg);
  1494.  
  1495.     /* restore the stack */
  1496.     xlpop();
  1497.  
  1498.     /* return the argument */
  1499.     return (arg);
  1500. }
  1501.  
  1502. /* evmatch - get an evaluated argument and match its type */
  1503. LOCAL LVAL evmatch(type,pargs)
  1504.   int type; LVAL *pargs;
  1505. {
  1506.     LVAL arg;
  1507.  
  1508.     /* protect some pointers */
  1509.     xlsave1(arg);
  1510.  
  1511.     /* make sure the argument exists */
  1512.     if (!consp(*pargs))
  1513.         toofew(*pargs);
  1514.  
  1515.     /* get the argument value */
  1516.     arg = car(*pargs);
  1517.  
  1518.     /* move the argument pointer ahead */
  1519.     *pargs = cdr(*pargs);
  1520.  
  1521.     /* evaluate the argument */
  1522.     arg = xleval(arg);
  1523.  
  1524.     /* check its type */
  1525.     if (type == LIST) {
  1526.         if (arg && ntype(arg) != CONS)
  1527.             xlbadtype(arg);
  1528.     }
  1529.     else {
  1530.         if (arg == NIL || ntype(arg) != type)
  1531.             xlbadtype(arg);
  1532.     }
  1533.  
  1534.     /* restore the stack */
  1535.     xlpop();
  1536.  
  1537.     /* return the argument */
  1538.     return (arg);
  1539. }
  1540.  
  1541. /* toofew - too few arguments */
  1542. LOCAL VOID toofew(args)
  1543.   LVAL args;
  1544. {
  1545.     xlerror("too few arguments",args);
  1546. }
  1547.  
  1548. /* toomany - too many arguments */
  1549. LOCAL VOID toomany(args)
  1550.   LVAL args;
  1551. {
  1552.     xlerror("too many arguments",args);
  1553. }
  1554.  
  1555.